perm filename PLTSRT.F4[MSS,LCS]1 blob
sn#079058 filedate 1974-03-19 generic text, type T, neo UTF8
00010 C SUBRS. ALPHA, RHORZ, SLUR, JUGGLE, LOOP, PLTSRT, LINES, RDRAW
00020
00100 C****** FOR LISTS OF LETTERS, ETC. *******
00200 SUBROUTINE ALPHA
00300 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00600 EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
00700 1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
00900 COMMON/STF/RSTFAC(8),RSTJC
01000
01100 IF(JA.EQ.20)GO TO 20
01200 CC RSTJC=RSTFAC(JC+4)
01300 JA=5
01400 54 R=19.7*RJE*RSTJC
01500 J=R
01600 RND=R-J
01700 R=0
01800 DO 50 KA=4,6
01900 JY=RJQ(KA)*100.+.2
02000 JX=1000000
02100 DO 53 LA=1,4
02200 JF=JY/JX
02300 CC IF(JF.LT.90)CALL NOTWRT
02350 IF(JF.NE.47.AND.JF.LT.90)CALL NOTWRT
02400 C 47=BLANK (WAS 99)
02500 JY=JY-JF*JX
02600 JB=JB+J
02700 R=R+RND
02800 IF(R.LT.1.0)GO TO 53
02900 JB=JB+1
03000 R=R-1.0
03100 53 JX=JX/100
03200 50 CONTINUE
03240 RETURN
03400 C FOR TRILLS
03500 20 R=RJB
03600 C R SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
03750 C 20, POS1, STF, NT#, 0, POS2, X IF X=1 THEN NO WAVEY LINE
03800 RJE=.65
03850 JE=0
03900 JA=5
04000 JF=29
04100 C DRAWS T
04200 CALL NOTWRT
04300 JF=27
04400 C DRAWS R
04500 JB=JB+11*RSTJC
04600 51 CALL NOTWRT
04750 IF(JG.NE.0)RETURN
04800 JB=JB+16*RSTJC
05000 C RETURN IF NO WAVY LINE IS NEEDED
05100 JA=4
05200 RJB=R+4.*RSTJC
05300 JG=-2
05400 C JG IS SWITCH TO DRAW WIGGLE
05500 RJE=RJD+.8
05600 CALL ITMSUB
05800 END
05900
06000 FUNCTION RHORZ(R)
06100 RHORZ=R*5.96-596.
06200 END
06300
06400
06500 SUBROUTINE SLUR
06600 IMPLICIT INTEGER(A-Q,T-Z)
06700 REAL CENTR,PWDS
06710 COMMON /XRN/RN(4000) /PLTR/PLT,RHT,DIS
06900 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07000 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(8),RSTJC
07200 EQUIVALENCE (RJG,RJQ(5)),(RJF,RJQ(4)),(JG,JQ(5)),
07300 1(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
07400 1,(JF,JQ(4)),(RJD,RJQ(2)),(RJE,RJQ(3)),(RF,RJQ(20))
07500 DIMENSION SLURX(53),SLURY(53),RSEQ(26)
07600 DATA RSEQ/70.0,64.0,59.0,53.9,49.0,44.1,40.0,35.8,32.0,28.2,
07700 1 25.0,21.8,19.0,16.3,14.0,11.9,10.0,8.4,6.8,5.3
07800 1 ,4.0,2.9,2.0,1.4,1.0,.07/
07805 IF(JA.NE.12)GO TO 2
07810 RA=5.96*RSTJC*RJE
07815 L=3
07820 IF(JG.LE.JF)JG=JG+360
07822 JH=6
07823 IF(PLT)JH=1
07825 DO 3 K=JF,JG,JH
07830 R=K
07835 CALL LINES(RJB+RA*SIND(R),CENTR+RA*COSD(R),L)
07840 3 L=2
07845 C JA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2
07850 RETURN
07900 2 JJ=1
07902 KQ=1
07903 TWICE=0
07905 IF(PLT)GO TO 21
07910 TWICE=-1
07912 KQ=3
07930 21 RST7=RSTJC*7.
08000 IF(RJF.GT.1000)CALL RNOTE(RJF)
08010 GO TO (5,6,7),JH+4
08015 GO TO 4
08020 5 R=32
08025 C AFTER DOTTED NOTE
08030 GO TO 8
08040 6 R=22
08045 C BETWEEN NOTES
08050 8 RX=-1.3
08060 GO TO 9
08070 7 R=7
08080 RX=RSTJC
08090 9 RJB=RJB+R*RSTJC
08100 RJF=RJF+RX
08250 4 RXX=RHORZ(RJF)-RJB
08260 RTILT=(RJE-RJD)*RST7
08270 80 RX=SQRT(RXX**2+RTILT**2)
08280 1 R=CENTR
08300 IF(JH.GT.0)GO TO 180
08400 C FOR BRACKETS
08410 RB=RX/52.
08500 DO 81 K=1,53
08600 81 SLURX(K)=RB*(K-1)+RJB
08700 RA=-RJG*RST7
08800 R=R-RA
08900 RW=630.
09010 RB=RA/RW
09100 DO 82 K=1,26
09200 SLURY(K)=RW*RB+R
09300 SLURY(54-K)=SLURY(K)
09400 82 RW=RW-RSEQ(K)
09500 SLURY(27)=SLURY(26)
09600 L=53
09700
09800 89 IF(RTILT.EQ.0)GO TO 87
09900 CC R=RTILT*RF
10000 RW=ATAN2(RTILT,RXX)
10100 RA=SIN(RW)
10200 RB=COS(RW)
10300 RZ=SLURX(1)
10400 RW=SLURY(1)
10500 DO 84 K=1,L
10600 SLURX(K)=SLURX(K)-RZ
10700 84 SLURY(K)=SLURY(K)-RW
10800 DO 83 K=1,L
10900 R=SLURX(K)
11000 SLURX(K)=RB*R-RA*SLURY(K)+RZ
11100 83 SLURY(K)=RB*SLURY(K)+RA*R+RW
11200
11300 87 CALL LINES(SLURX(JJ),SLURY(JJ),3)
11400 DO 88 K=JJ+1,L,KQ
11500 88 CALL LINES(SLURX(K),SLURY(K),2)
11510 IF(TWICE)RETURN
11520 TWICE=-1
11530 RJG=RJG+.1
11540 GO TO 1
11600 RETURN
11700 180 RW=R+RJG*RST7
11750 KQ=1
11800 RX=RX+RJB
11900 RA=(RJE-RJD)*RST7
12000 SLURX(1)=RJB
12100 SLURY(1)=R
12200 SLURX(2)=RJB
12300 SLURY(2)=RW
12400 SLURX(3)=RX
12500 SLURY(3)=RW+RA
12600 SLURX(4)=RX
12700 SLURY(4)=R+RA
12800 L=4
12900 IF(JH.EQ.2)L=3
13000 IF(JH.EQ.3)JJ=2
13010 TWICE=-1
13100 GO TO 87
13200 END
13300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
13400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
13500
13600
13700 C******** JUGGLER ********
13800 SUBROUTINE JUGGLE
13900 IMPLICIT INTEGER(A-Z)
14000 REAL DIS,RJB,PWDS,DISX,RN,RJC,RJB,RJQ,RJJ,RJF,RHT,A,B
14100 COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
14300 COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
14600
14700 ITEM=ITEM-1
14800 JX=RN(MEDIT)+3
14900 C WD CNT OF OLD ITEM
15000 C I-IX IS WD CNT OF NEW ITEM
15100 JY=IX
15200 Z=I-IX-JX
15300 C SPACE CHANGE
15400 IF(Z)2751,172,751
15500 751 CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15600 JY=IX+Z
15700 GO TO 172
15800
15900 2751 CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
16000
16100 172 J=RN(JY)+2
16200 CALL LOOP(0,J,1,MEDIT,JY,RN)
16300 I=IX+Z
16400
16500 1751 X=ITEM+1
16600 JX=WDS(X22+1)-WDS(X22)
16700 J=WDS(X+1)-WDS(X)
16800 Y=J-JX
16900 JX=WDS(X)+Y+1
17000 IF(Y)2851,182,282
17100 282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
17200 GO TO 182
17300
17400 2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
17500 JX=WDS(X)+1
17600
17700 182 CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
17800 DO 183 K=X22+1,X
17900 PWDS(K)=PWDS(K)+Z
18000 183 WDS(K)=WDS(K)+Y
18100 ST(2)=WDS(X)
18200 X22=0
18400 END
18500
18600
18700 SUBROUTINE LOOP(I,J,K,L,M,N)
18800 DIMENSION N(1)
18900 DO 1 NN=I,J,K
19000 1 N(NN+L)=N(NN+M)
19200 END
19300
19400
19500 SUBROUTINE PLTSRT
19600 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
19700 IMPLICIT INTEGER(S-Z)
19800 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
19940 COMMON/DPY/P(4000),WDS(250),MEDIT,IGO
20000 DO 4 K=1,ITEM
20100 L=PWDS(K)
20150 A=RN(L+2)
20200 P(K)=A+1000*RN(L+3)
20250 4 IF(A.LT.0)P(K)=-10000
20275 C PLOTS ALL NEG. HORIZ. POSITIONS FIRST
20300 Y=I
20500 2 A=P(1)
20600 L=1
20700 DO 1 K=1,ITEM
20800 IF(A.LE.P(K))GO TO 1
20900 A=P(K)
21000 L=K
21100 1 CONTINUE
21200 IF(A.EQ.10000.)RETURN
21300 C ALL ITEMS HAVE NOW BEEN SHUFFLED
21400 V=PWDS(L)
21500 P(L)=10000
21600 L=RN(V)+2
21700 CALL LOOP(0,L,1,Y,V,RN)
21800 Y=Y+L+1
21900 GO TO 2
22000 END
22100
22200
22300
22400 SUBROUTINE BOX(I,R,STFF)
22500 COMMON /SIZ/RSZ,JCEN,KCEN /XRN/RN(4000) /STF/RSTFAC(8),RSTJC
22800 COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
22900 DIMENSION N(100),STFF(1)
22950 EQUIVALENCE (N,RN(2901))
23000 IF(I)GO TO 4
23100 K=R+4
23200 K=(STFF(K)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
23300 1 -60.0)*RSZ-KCEN
23400 C AMOD IS FOR MINI NOTES AND CLEFS
23500 L=RHORZ(RN(I+2))*RSZ-JCEN-25
23600 IF(IABS(L).GT.550)L=512
23700 IF(IABS(K).GT.550)K=512
23800 1 CALL ALINE(L,K,L+50,K)
23900 CALL RVECT(0,100)
24000 CALL RVECT(-50,0)
24100 CALL RVECT(0,-100)
24200 L=L+25
24300 2 CALL ALINE(L,K-25,L,K+125)
24450 3 CALL DPYOUT(1)
24500 RETURN
24600 4 IF(I.LT.-1)GO TO 5
24700 CALL DPYSET(3,N,100)
24800 CALL DPYBRT(3)
24900 5 L=RHORZ(R)*RSZ-JCEN
25000 IF(IABS(L).GT.550)GO TO 6
25050 C DOESN'T TRY TO DRAW LINE OFF SCREEN
25100 CALL SETPOG(3)
25200 CALL ALINE(L,-511,L,511)
25300 CALL DPYOUT(3)
25400 6 CALL SETPOG(1)
25600 END
25700
25800 SUBROUTINE LINES(A,B,L)
25900 COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
26000 COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
26100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
26200 COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
26400 EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000)),(RXGP,WDS(250))
26402 1,(JJ2,JJ(2))
26500 DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/,XGP/1200.0/
26600 C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
26700 22 GO TO 23
26800 C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
26900 24 AA=CC-DD*ABS(A)/BB
27000 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
27100 B=B*AA
27200 23 IF(IPLT)GO TO 2
27300 M=A*RSZ
27400 N=B*RSZ
27500 IF(RSZ.LE.0.8571)GO TO 3
27600 C NEXT FOR DISPLAY MAGNIFICATION
27700 M=M-JCEN
27800 N=N-KCEN
27900 IF(JA.NE.10)GO TO 5
28000 C NEXT INSURES DISPLAY OF STAFF LINES
28100 IF(M.GT.511)M=511
28200 IF(M.LT.-511)M=-511
28400 5 IF(IABS(M).LT.512.AND.IABS(N).LT.512)GO TO 4
28500 C NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
28600 KZ=-1
28700 RETURN
28800 4 IF(KZ.EQ.0)GO TO 6
28900 KZ=0
29000 GO TO 1
29050 3 IF(JA.EQ.44)GO TO 6
29075 C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
29100 K=B
29200 IF(K.GT.ITOP)ITOP=B
29300 IF(K.LT.IBOT)IBOT=B
29302 6 IF(JJ2.GT.3990)RETURN
29400 IF(L.EQ.3)GO TO 1
29500 CALL AVECT(M,N)
29600 RETURN
29700 1 CALL AIVECT(M,N)
29800 RETURN
29900 2 IF(IPLT.EQ.-2)RETURN
30000 CC AX=.5
30100 CC IF(A)AX=-AX
30200 CC BX=.5
30300 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
30400 CC IF(B)BX=-BX
30500 C AX AND BX ARE FOR ROUND-OFF
30600 IF(IXRX.EQ.0)GO TO 9
30610 M=ROFF(RXGP-B*RHT)
30620 N=ROFF(XGP+A*DIS)
30700 CC M=-B*RHT-BX+RXGP
30800 CC N=A*DIS+XGP+AX
30900 GO TO 8
31000 CC9 M=A*DIS+AX
31100 CC N=B*RHT+BX
31110 9 M=ROFF(A*DIS)
31120 N=ROFF(B*RHT)
31200 8 CALL PLOT(M,N,L)
31400 END
31540
31600 SUBROUTINE RDRAW(I,S,XY,X,RJB,CENTR,RMINI)
31700 C TO X,Y INTO ONE WORD
31800 DIMENSION XY(1)
31900 DO 2 K=I,IFIX(S)
32000 L=2
32100 Y=XY(K)
32200 IF(Y.LT.1000.)GO TO 3
32300 L=3
32400 Y=Y-1000.
32500 C >1000 = INVIS. LINE
32600 3 M=Y
32700 Y=(Y-M)*1000.
32800 IF(Y.GT.100.)Y=100-Y
32900 C Y NUMBERS .GT.100 ARE NEG.
33000 B=Y*X+CENTR
33100 IF(M.GT.60)M=100-M
33200 A=M*RMINI+RJB
33300 2 CALL LINES(A,B,L)
33500 END